home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Languages / MS Cobol4.5 / DEMO / LOGOPER.CBL < prev    next >
Text File  |  1991-04-08  |  10KB  |  209 lines
  1.       $set ans85 noosvs mf
  2.       *******************************************************************
  3.       *                                                                 *
  4.       *                (C) Micro Focus Ltd. 1990                        *
  5.       *                                                                 *
  6.       *                      LOGOPER.CBL                                *
  7.       *                                                                 *
  8.       * This program gives an example of how to use the logical         *
  9.       * call-by-name routines. It uses three, namely                    *
  10.       *                                                                 *
  11.       *    "CBL_OR"                                                     *
  12.       *    "CBL_AND"                                                    *
  13.       *    "CBL_XOR"                                                    *
  14.       *                                                                 *
  15.       * The program also uses a selection of other call-by-name         *
  16.       * routines, mainly for screen handling.                           *
  17.       *                                                                 *
  18.       * The program puts a string of characters on the screen with      *
  19.       * various attributes. These attributes are then manipulated       *
  20.       * via the logical call-by-name routines - according to which      *
  21.       * key has been pressed on the keyboard.                           *
  22.       *                                                                 *
  23.       * The program tends to use values in Hex, where their             *
  24.       * significance is bitwise.                                        *
  25.       *                                                                 *
  26.       * The layout of a screen attribute byte is given below to         *
  27.       * illustrate the effect that the logical call-by-names are        *
  28.       * having.                                                         *
  29.       *                                                                 *
  30.       *                    Attribute Byte                               *
  31.       *                    --------------                               *
  32.       *    Bit    7     6     5     4     3     2     1     0           *
  33.       *          BL    BR    BG    BB    FI    FR    FG    FB           *
  34.       *                                                                 *
  35.       *    where:                                                       *
  36.       *        BL  -   make the foreground blink                        *
  37.       *        BR, BG, BB  -   The RGB colour value for the background  *
  38.       *        FI  -   make the foreground colour high intensity        *
  39.       *        FR, FG, FB  -   The RGB colour value for the foreground  *
  40.       *                                                                 *
  41.       *    The RGB table is:                                            *
  42.       *         R  G  B   Colour    High Intensity Colour               *
  43.       *         0  0  0   Black     Grey                                *
  44.       *         0  0  1   Blue      Light Blue                          *
  45.       *         0  1  0   Green     Light Green                         *
  46.       *         0  1  1   Cyan      Light Cyan                          *
  47.       *         1  0  0   Red       Light Red                           *
  48.       *         1  0  1   Magenta   Light Magenta                       *
  49.       *         1  1  0   Brown     Yellow                              *
  50.       *         1  1  1   White     Bright White                        *
  51.       *                                                                 *
  52.       *******************************************************************
  53.        working-storage section.
  54.        01  clr-char            pic x value space.
  55.        01  clr-attr            pic x value x"0f".
  56.  
  57.        78  text-start          value 29.
  58.        78  text-len            value 23.
  59.        78  text-end            value 51.
  60.  
  61.        01  text-scr-pos.
  62.            03  text-row        pic 9(2) comp-x value 12.
  63.            03  text-col        pic 9(2) comp-x value text-start.
  64.        01  text-char-buffer    pic x(text-len)
  65.                                value "Text-in-various-colours".
  66.        01  text-attr-buffer.
  67.            03  first-word      pic x(4) value all x"0f".
  68.            03  second-word     pic x(4) value all x"2c".
  69.            03  third-word      pic x(7) value all x"14".
  70.            03  third-space     pic x value x"30".
  71.            03  fourth-word     pic x(7) value all x"59".
  72.        01  text-length         pic 9(4) comp-x value text-len.
  73.  
  74.        01  char-read           pic x.
  75.        01  char-length         pic 9(9) comp-5 value 1.
  76.  
  77.        01  quit-flag           pic 9 comp-x.
  78.            88 not-ready-to-quit    value 0.
  79.            88 ready-to-quit        value 1.
  80.  
  81.        01  csr-pos.
  82.            03  csr-row         pic 9(2) comp-x value 12.
  83.            03  csr-col         pic 9(2) comp-x value 39.
  84.        01  csr-attr            pic x.
  85.        01  csr-length          pic 9(4) comp-x value 1.
  86.  
  87.        01  blink-mask          pic x value x"80".
  88.        01  steady-mask         pic x value x"7f".
  89.  
  90.        01  invert-mask         pic x(text-len) value all x"7f".
  91.  
  92.        78  instr-len           value 41.
  93.        01  instr-length        pic 9(4) comp-x value instr-len.
  94.        01  instr               pic x(instr-len)
  95.                value "Press (L)eft, (R)ight, (I)nvert or (Q)uit".
  96.        01  instr-pos.
  97.            03  instr-row       pic 9(2) comp-x value 8.
  98.            03  instr-col       pic 9(2) comp-x value 19.
  99.  
  100.        procedure division.
  101.  
  102.        main section.
  103.            perform init-screen
  104.            set not-ready-to-quit to true
  105.            perform until ready-to-quit
  106.                perform read-keyboard
  107.                evaluate char-read
  108.                    when "L"
  109.                        perform csr-move-left
  110.                    when "R"
  111.                        perform csr-move-right
  112.                    when "I"
  113.                        perform invert-text
  114.                    when "Q"
  115.                        set ready-to-quit to true
  116.                end-evaluate
  117.            end-perform
  118.            stop run
  119.            .
  120.  
  121.        init-screen section.
  122.            call "cbl_clear_scr" using clr-char
  123.                                       clr-attr
  124.            call "cbl_write_scr_chars" using instr-pos
  125.                                             instr
  126.                                             instr-length
  127.            call "cbl_write_scr_chars" using text-scr-pos
  128.                                             text-char-buffer
  129.                                             text-length
  130.            perform put-attrs-on-screen
  131.            perform blink-cursor
  132.            .
  133.  
  134.        read-keyboard section.
  135.            call "cbl_read_kbd_char" using char-read
  136.            call "cbl_toupper" using char-read
  137.                                     by value char-length
  138.            .
  139.  
  140.  
  141.        csr-move-left section.
  142.            perform steady-cursor
  143.            subtract 1 from csr-col
  144.            if csr-col < text-start
  145.                move text-end to csr-col
  146.            end-if
  147.            perform blink-cursor
  148.            .
  149.  
  150.        csr-move-right section.
  151.            perform steady-cursor
  152.            add 1 to csr-col
  153.            if csr-col > text-end
  154.                move text-start to csr-col
  155.            end-if
  156.            perform blink-cursor
  157.            .
  158.  
  159.  
  160.        blink-cursor section.
  161.       *
  162.       * Turn on the blink bit at the current attribute.
  163.       *
  164.            call "cbl_read_scr_attrs" using csr-pos
  165.                                            csr-attr
  166.                                            csr-length
  167.            call "cbl_or" using blink-mask
  168.                                csr-attr
  169.                                by value 1
  170.            call "cbl_write_scr_attrs" using csr-pos
  171.                                             csr-attr
  172.                                             csr-length
  173.            .
  174.  
  175.        steady-cursor section.
  176.       *
  177.       * Turn off the blink bit at the current attribute.
  178.       *
  179.            call "cbl_read_scr_attrs" using csr-pos
  180.                                            csr-attr
  181.                                            csr-length
  182.            call "cbl_and" using steady-mask
  183.                                 csr-attr
  184.                                 by value 1
  185.            call "cbl_write_scr_attrs" using csr-pos
  186.                                             csr-attr
  187.                                             csr-length
  188.            .
  189.  
  190.        invert-text section.
  191.       *
  192.       * invert the bits that set the foreground colour, the background
  193.       * colour, and the intensity bits, but leave the blink bit alone.
  194.       *
  195.            call "cbl_read_scr_attrs" using text-scr-pos
  196.                                            text-attr-buffer
  197.                                            text-length
  198.            call "cbl_xor" using invert-mask
  199.                                 text-attr-buffer
  200.                                 by value text-len
  201.            perform put-attrs-on-screen
  202.            .
  203.  
  204.        put-attrs-on-screen section.
  205.            call "cbl_write_scr_attrs" using text-scr-pos
  206.                                             text-attr-buffer
  207.                                             text-length
  208.            .
  209.